{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Language where


import qualified Data.List as List
import qualified SExpressions as SE
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.Error
import qualified Stepwise as SW
import ResultState
import Identifier
import Pointer
import qualified Environment as Env
import qualified Heap
import Result
import Data.Maybe
import qualified Array
import Accessor
import ThreadId
import qualified Choice as C
import qualified Priority


type Heap = Heap.Heap Value

type Environment = Env.Environment Value

data ThreadState = ThreadState Environment Environment

data Thread = Thread ThreadId Priority.Priority ThreadState (ThreadProcedure Value)

type ThreadPool = Map.Map ThreadId Thread

type Graveyard = Map.Map ThreadId (Value, ThreadState)

data MachineState = MachineState Heap Trail ThreadId ThreadPool Graveyard [Integer]

type Trace = ([ThreadId], Result Exception MachineState)

data SystemCall a = GetThreadId (ThreadId -> ThreadProcedure a)
                  | SpawnThread (ThreadProcedure Value) (ThreadId -> ThreadProcedure a)
                  | forall r. KernelFunctionCall Bool (KernelFunction r) (r -> ThreadProcedure a)
                  | Join ThreadId (ThreadProcedure a)
                  | GetThreadPriority (Priority.Priority -> ThreadProcedure a)
                  | SetThreadPriority Priority.Priority (ThreadProcedure a)
                  | forall r. CallCC ((r -> ThreadProcedure Value) -> ThreadProcedure Value) (r -> ThreadProcedure a)


type KernelFunction a = ResultState MachineState Value a

data ThreadProcedure a = ThreadProcedure { extractStepwise :: SW.Stepwise ThreadState Value SystemCall a }

type NativeFunction a = [Value] -> ThreadProcedure a

data CallStrategy = Strict
                  | Macro

type SourceLocation = (String, Integer, Integer)

type SourceRange = (SourceLocation, SourceLocation)

data Value = Integer Integer (Maybe SourceRange)
           | String String (Maybe SourceRange)
           | Boolean Bool (Maybe SourceRange)
           | Unit (Maybe SourceRange)
           | NativeFunction String (NativeFunction Value) (Maybe SourceRange)
           | Closure CallStrategy Environment Identifier (ThreadProcedure Value) (Maybe SourceRange)
           | List [Value] (Maybe SourceRange)
           | Symbol String (Maybe SourceRange)
           | Address Pointer (Maybe SourceRange)
           | ThreadId ThreadId (Maybe SourceRange)
           | Keyword String (Maybe SourceRange)
           | Dictionary (Map.Map Value Value) (Maybe SourceRange)
           | Snapshot MachineState (Maybe SourceRange)
           | HeapSnapshot Heap (Maybe SourceRange)
           | TraceValue Trace (Maybe SourceRange)
           | Path [ThreadId] (Maybe SourceRange)


data Trail = Trail [Value]

type Exception = Value

instance Show ThreadState where
  show (ThreadState _ _) = "<threadstate>"


instance Show (SystemCall a) where
  show (GetThreadId _)            = "GetThreadId"
  show (SpawnThread _ _)          = "SpawnThread"
  show (KernelFunctionCall _ _ _) = "KernelFunctionCall"
  show (Join _ _)                 = "Join"
  show (GetThreadPriority _)      = "GetThreadPriority"
  show (SetThreadPriority _ _)    = "SetThreadPriority"


instance Monad ThreadProcedure where
    return                    = ThreadProcedure . return
    ThreadProcedure sw >>= g  = ThreadProcedure $ sw >>= (\b -> extractStepwise $ g b)


instance WithState ThreadProcedure ThreadState where
    getCurrentState   = ThreadProcedure getCurrentState
    setCurrentState s = ThreadProcedure (setCurrentState s)


instance MonadError Exception ThreadProcedure where
    throwError           = ThreadProcedure . throwError
    catchError try catch = ThreadProcedure $ catchError (extractStepwise try) (extractStepwise . catch)


instance SW.Sibling (SW.Stepwise ThreadState Exception SystemCall) SystemCall where
    GetThreadId c >>>= sw               = GetThreadId $ \n -> ThreadProcedure (extractStepwise (c n) >>= sw)
    SpawnThread tp c >>>= sw            = SpawnThread tp $ \tid -> ThreadProcedure (extractStepwise (c tid) >>= sw)
    KernelFunctionCall b kf c >>>= sw   = KernelFunctionCall b kf $ \r -> ThreadProcedure (extractStepwise (c r) >>= sw)
    Join tid c >>>= sw                  = Join tid $ ThreadProcedure (extractStepwise c >>= sw)
    GetThreadPriority c >>>= sw         = GetThreadPriority $ \r -> ThreadProcedure (extractStepwise (c r) >>= sw)
    SetThreadPriority p c >>>= sw       = SetThreadPriority p $ ThreadProcedure (extractStepwise c >>= sw)
    CallCC f c >>>= sw                  = CallCC f (\r -> ThreadProcedure $ extractStepwise (c r) >>= sw)


instance Show Value where
    show = show . SE.asSExpr


instance Eq Value where
    v == v' = equalValues v v'


instance Ord Value where
    compare v v' = case valueOrdering v v' of
                     Just o  -> o
                     Nothing -> error "Undefined ordering"


instance SE.AsSExpr Value where
    asSExpr (Integer n _)            = SE.Integer n ((), ())
    asSExpr (String s _)             = SE.String s ((), ())
    asSExpr (Boolean True _)         = SE.Symbol "#t" ((), ())
    asSExpr (Boolean False _)        = SE.Symbol "#f" ((), ())
    asSExpr (Unit _)                 = SE.List [] ((), ())
    asSExpr (List vs _)              = SE.List (map SE.asSExpr vs) ((), ())
    asSExpr (Symbol s _)             = SE.Symbol s ((), ())
    asSExpr (Closure Strict _ _ _ _) = SE.Symbol "#<closure/strict>" ((), ())
    asSExpr (Closure Macro _ _ _ _)  = SE.Symbol "#<closure/macro>" ((), ())
    asSExpr (Address ptr _)          = SE.Symbol ("#PTR[" ++ show ptr ++ "]") ((), ())
    asSExpr (ThreadId id _)          = SE.Symbol ("#TID[" ++ show id ++ "]") ((), ())
    asSExpr (Keyword id _)           = SE.Symbol (':' : id)  ((), ())
    asSExpr (Dictionary m _)         = SE.List (SE.Symbol "dict" ((), ()) : map aux (Map.toList m)) ((), ())
                                         where
                                           aux (k, v) = SE.List [ SE.asSExpr k, SE.asSExpr v ] ((), ())
    asSExpr (Snapshot ms _)          = SE.Symbol "#<machine-state>" ((), ())
    asSExpr (HeapSnapshot ms _)      = SE.Symbol "#<heap>" ((), ())
    asSExpr (TraceValue trace _)     = SE.Symbol "#<trace>" ((), ())
    asSExpr (Path _ _)               = SE.Symbol "#<path>" ((), ())


instance Show Trail where
    show (Trail trail) = "<" ++ List.intercalate " " (map show trail) ++ ">"


instance Show MachineState where
    show (MachineState heap trail threadId threads graveyard freshInts) =
        "MS[" ++ List.intercalate "; " [ "Trail: " ++ show trail
                                       , "#Threads: " ++ show (Map.size threads) ++ "/" ++ show (Map.size graveyard)
                                       ] ++ "]"


data TypePredicate = TypePredicate (Value -> Bool) String

instance Show TypePredicate where
    show (TypePredicate _ s) = s


hasType :: Value -> TypePredicate -> Bool
-----------------------------------------
hasType val (TypePredicate pred _) = pred val


emptyTrail :: Trail
-------------------
emptyTrail = Trail []


extendTrail :: Value -> Trail -> Trail
--------------------------------------
extendTrail v (Trail vs) = Trail (v : vs)


integerType :: TypePredicate
----------------------------
integerType = TypePredicate aux "integer"
    where
      aux (Integer _ _) = True
      aux _             = False


stringType :: TypePredicate
---------------------------
stringType = TypePredicate aux "string"
    where
      aux (String _ _) = True
      aux _            = False


unitType :: TypePredicate
-------------------------
unitType = TypePredicate aux "unit"
    where
      aux (Unit _) = True
      aux _        = False


booleanType :: TypePredicate
----------------------------
booleanType = TypePredicate aux "boolean"
    where
      aux (Boolean _ _) = True
      aux _             = False


symbolType :: TypePredicate
---------------------------
symbolType = TypePredicate aux "symbol"
    where
      aux (Symbol _ _) = True
      aux _            = False


functionType :: TypePredicate
-----------------------------
functionType = TypePredicate aux "function"
    where
      aux (NativeFunction _ _ _) = True
      aux (Closure _ _ _ _ _)    = True
      aux _                      = False


listType :: TypePredicate
-------------------------
listType = TypePredicate aux "list"
    where
      aux (List _ _) = True
      aux _          = False


anyType :: TypePredicate
------------------------
anyType = TypePredicate aux "any"
    where
      aux _ = True


addressType :: TypePredicate
----------------------------
addressType = TypePredicate aux "address"
    where
      aux (Address _ _) = True
      aux _             = False


threadIdType :: TypePredicate
-----------------------------
threadIdType = TypePredicate aux "thread-id"
    where
      aux (ThreadId _ _) = True
      aux _              = False


dictionaryType :: TypePredicate
-------------------------------
dictionaryType = TypePredicate aux "dictionary"
    where
      aux (Dictionary _ _) = True
      aux _                = False


snapshotType :: TypePredicate
-----------------------------
snapshotType = TypePredicate aux "snapshot"
    where
      aux (Snapshot _ _) = True
      aux _              = False


heapSnapshotType :: TypePredicate
---------------------------------
heapSnapshotType = TypePredicate aux "heap-snapshot"
    where
      aux (HeapSnapshot _ _) = True
      aux _                  = False


traceType :: TypePredicate
--------------------------
traceType = TypePredicate aux "trace"
    where
      aux (TraceValue _ _) = True
      aux _                = False


pathType :: TypePredicate
-------------------------
pathType = TypePredicate aux "path"
    where
      aux (Path _ _) = True
      aux _          = False



typeOf :: Value -> TypePredicate
--------------------------------
typeOf (Integer _ _)          = integerType
typeOf (String _ _)           = stringType
typeOf (Unit _)               = unitType
typeOf (Boolean _ _)          = booleanType
typeOf (Symbol _ _)           = symbolType
typeOf (NativeFunction _ _ _) = functionType
typeOf (Closure _ _ _ _  _)   = functionType
typeOf (List _ _)             = listType
typeOf (Address _ _)          = addressType
typeOf (ThreadId _ _)         = threadIdType
typeOf (Dictionary _ _)       = dictionaryType
typeOf (Snapshot _ _)         = snapshotType
typeOf (HeapSnapshot _ _)     = heapSnapshotType
typeOf (TraceValue _ _)       = traceType
typeOf (Path _ _)             = pathType


equalValues :: Value -> Value -> Bool
-------------------------------------
equalValues = eq
    where
      eq (Integer n _)   (Integer n' _)     = n == n'
      eq (Boolean b _)   (Boolean b' _)     = b == b'
      eq (Unit _)        (Unit _)           = True
      eq (String s _)    (String s' _)      = s == s'
      eq (ThreadId id _) (ThreadId id' _)   = id == id'
      eq (Address p _)   (Address p' _)     = p == p'
      eq (Symbol s _)    (Symbol s' _)      = s == s'
      eq (Keyword x _)   (Keyword x' _)     = x == x'
      eq (List xs _)     (List xs' _)       = if length xs == length xs'
                                              then and $ map (uncurry equalValues) (zip xs xs')
                                              else False
      eq  _             _               = False


valueOrdering :: Value -> Value -> Maybe Ordering
-------------------------------------------------
valueOrdering = aux
    where
      lexico []     []       = return EQ
      lexico []     _        = return LT
      lexico _      []       = return GT
      lexico (v:vs) (v':vs') = do o <- aux v v'
                                  case o of
                                    LT -> return LT
                                    GT -> return GT
                                    EQ -> lexico vs vs'

      cmp x y = Just $ compare x y
      fail    = Nothing

      aux (Integer n _) (Integer n' _)                         = cmp n n'
      aux (String s _) (String s' _)                           = cmp s s'
      aux (Boolean b _) (Boolean b' _)                         = cmp b b'
      aux (Unit _) (Unit _)                                    = return EQ
      aux (List vs _) (List vs' _)                             = lexico vs vs'
      aux (Symbol s _) (Symbol s' _)                           = cmp s s'
      aux (Address p _) (Address p' _)                         = cmp p p'
      aux (ThreadId tid _) (ThreadId tid' _)                   = cmp tid tid'
      aux (Keyword kw _) (Keyword kw' _)                       = cmp kw kw'
      aux v@(Dictionary _ _) v'@(Dictionary _ _)               = fail
      aux v@(NativeFunction _ _ _) v'@(NativeFunction _ _ _)   = fail
      aux v@(Closure _ _ _ _ _) v'@(Closure _ _ _ _ _)         = fail
      aux v v'                                             = do o <- ord v
                                                                o' <- ord v'
                                                                return $ compare o o'


      ord (Integer _ _)            = Just 0
      ord (String _ _)             = Just 1
      ord (Boolean _ _)            = Just 2
      ord (Unit _)                 = Just 3
      ord (List xs _)              = Just 4
      ord (Symbol _ _)             = Just 5
      ord (Address _ _)            = Just 6
      ord (ThreadId _ _)           = Just 7
      ord (Keyword _ _)            = Just 8
      ord (Dictionary _ _)         = Nothing
      ord (NativeFunction _ _ _)   = Nothing
      ord (Closure _ _ _ _ _)      = Nothing
      ord (Snapshot _ _)           = Nothing
      ord (HeapSnapshot _ _)       = Nothing


yield :: SystemCall a -> ThreadProcedure a
------------------------------------------
yield = ThreadProcedure . SW.yield


$(generateAccessors [t| MachineState |] [ "heap", "trail", "nextThreadId", "threads", "graveyard", "freshIntegers" ])

$(generateAccessors [t| ThreadState |] [ "lexicalEnvironment", "dynamicEnvironment" ])

$(generateAccessors [t| Thread |] [ "threadId", "threadPriority", "threadState", "thradProcedure" ])


bind :: Identifier -> Value -> ThreadProcedure ()
-------------------------------------------------
bind id v = do update lexicalEnvironment $ Env.bind id v


systemCall :: SystemCall a -> ThreadProcedure a
-----------------------------------------------
systemCall sc = ThreadProcedure $ SW.yield sc


kernelFunctionCall :: Bool -> KernelFunction a -> ThreadProcedure a
-------------------------------------------------------------------
kernelFunctionCall b kf = systemCall $ KernelFunctionCall b kf return


getThreadId :: ThreadProcedure ThreadId
---------------------------------------
getThreadId = systemCall $ GetThreadId return


kfFreshThreadId :: KernelFunction ThreadId
----------------------------------------
kfFreshThreadId = do tid <- get nextThreadId
                     update nextThreadId ThreadId.next
                     return tid


kfFreshInteger :: KernelFunction Integer
----------------------------------------
kfFreshInteger = do ns <- get (listHead `from` freshIntegers)
                    update freshIntegers tail
                    return ns                    


freshInteger :: ThreadProcedure Integer
---------------------------------------
freshInteger = kernelFunctionCall False kfFreshInteger


kfDropCrumb :: Value -> KernelFunction ()
-----------------------------------------
kfDropCrumb crumb = update trail (extendTrail crumb)


kfSnapshot :: KernelFunction MachineState
-----------------------------------------
kfSnapshot = get state


snapshot :: ThreadProcedure MachineState
----------------------------------------
snapshot = kernelFunctionCall True kfSnapshot


kfHeapSnapshot :: KernelFunction Heap
-------------------------------------
kfHeapSnapshot = get heap


heapSnapshot :: ThreadProcedure Heap
------------------------------------
heapSnapshot = kernelFunctionCall True kfHeapSnapshot


dropCrumb :: Value -> ThreadProcedure ()
----------------------------------------
dropCrumb = kernelFunctionCall False . kfDropCrumb


spawnThread :: ThreadProcedure Value -> ThreadProcedure ThreadId
----------------------------------------------------------------
spawnThread tproc = systemCall $ SpawnThread tproc return


pause :: ThreadProcedure ()
---------------------------
pause = kernelFunctionCall True $ return ()


join :: ThreadId -> ThreadProcedure ()
--------------------------------------
join tid = systemCall $ Join tid $ return ()


setThreadPriority :: Priority.Priority -> ThreadProcedure ()
------------------------------------------------------------
setThreadPriority priority = systemCall $ SetThreadPriority priority $ return ()


getThreadPriority :: ThreadProcedure Priority.Priority
------------------------------------------------------
getThreadPriority = systemCall $ GetThreadPriority return


callCC :: ((a -> ThreadProcedure Value) -> ThreadProcedure Value) -> ThreadProcedure a
--------------------------------------------------------------------------------------
callCC func = systemCall $ CallCC func return


heapInteraction :: ResultState Heap Exception a -> ThreadProcedure a
--------------------------------------------------------------------
heapInteraction f = kernelFunctionCall True $ do h <- get heap
                                                 case run f h of
                                                   Failure e       -> throwError e
                                                   Success (a, h') -> do set heap h'
                                                                         return a



extractions :: [a] -> [(a, [a])]
--------------------------------
extractions []     = []
extractions (x:xs) = (x, xs) : [ (y, x:ys) | (y, ys) <- extractions xs ]


threadStep :: ThreadProcedure a -> ThreadState -> (ThreadState, Result Exception (Either a (SystemCall a)))
-----------------------------------------------------------------------------------------------------------
threadStep (ThreadProcedure sw) s = SW.step sw s


emptyGraveyard :: Graveyard
---------------------------
emptyGraveyard = Map.empty


bury :: ThreadId -> ThreadState -> Value -> Graveyard -> Graveyard
------------------------------------------------------------------
bury tid ts v gy = Map.insert tid (v, ts) gy


excavate :: ThreadId -> Graveyard -> Maybe (Value, ThreadState)
---------------------------------------------------------------
excavate tid = Map.lookup tid


isBuried :: ThreadId -> Graveyard -> Bool
-----------------------------------------
isBuried tid gy = Map.member tid gy


emptyThreadPool :: ThreadPool
-----------------------------
emptyThreadPool = Map.empty


createThreadPool :: [Thread] -> ThreadPool
------------------------------------------
createThreadPool = Map.fromList . map aux
  where
    aux thread = (getter threadId thread, thread)
    
    
addToPool :: Thread -> ThreadPool -> ThreadPool
-----------------------------------------------
addToPool thread pool = Map.insert (getter threadId thread) thread pool


isPoolEmpty :: ThreadPool -> Bool
---------------------------------
isPoolEmpty = Map.null


threadList :: ThreadPool -> [Thread]
------------------------------------
threadList = Map.elems


fetchThread :: ThreadId -> ThreadPool -> Thread
-----------------------------------------------
fetchThread tid = fromJust . Map.lookup tid


removeThread :: ThreadId -> ThreadPool -> ThreadPool
----------------------------------------------------
removeThread tid = Map.delete tid


step :: MachineState -> [(ThreadId, Result Exception MachineState)]
-------------------------------------------------------------------
step ms = map aux $ C.runChoice step' ms (repeat Nothing)
    where
      aux ((threadId, Just e), ms', _)  = (threadId, Failure e)
      aux ((threadId, Nothing), ms', _) = (threadId, Success ms')
            

step' :: C.Choice MachineState ThreadId (ThreadId, Maybe Exception)
-------------------------------------------------------------------
step' = do highestPriorityThreads <- collectHighestPriorityThreads
           let threadIds = Map.keys highestPriorityThreads
           activeThreadId <- C.choice threadIds
           let Thread _ activeThreadPriority activeThreadState activeThreadProc = fromJust $ Map.lookup activeThreadId highestPriorityThreads
           C.update threads $ removeThread activeThreadId
           result <- executeSingleStep activeThreadId activeThreadPriority activeThreadState activeThreadProc
           return result
    where
      collectHighestPriorityThreads = do ts <- liftM threadList $ C.get threads
                                         case ts of
                                           []   -> return Map.empty
                                           t:ts -> return $ collect (getter threadPriority t) [t] ts
          where
            collect priority acc []               = Map.fromList [ (getter threadId t, t) | t <- acc ]
            collect priority acc (thread:threads) = case compare (getter threadPriority thread) priority of
                                                      LT -> collect priority acc threads
                                                      EQ -> collect priority (thread : acc) threads
                                                      GT -> collect (getter threadPriority thread) [ thread ] threads

      executeSingleStep activeThreadId activeThreadPriority activeThreadState activeThreadProc =
          case threadStep activeThreadProc activeThreadState of
            (activeThreadState', Failure e)               -> return (activeThreadId, Just e)
            (activeThreadState', Success (Left val))      -> do C.update graveyard $ bury activeThreadId activeThreadState' val
                                                                return (activeThreadId, Nothing)
            (activeThreadState', Success (Right syscall)) -> handleSystemCall activeThreadId activeThreadPriority activeThreadState' syscall

      freshThreadId = do tid <- C.get nextThreadId
                         C.update nextThreadId ThreadId.next
                         return tid
                
      handleSystemCall activeThreadId activeThreadPriority activeThreadState (GetThreadId cont) =
          do C.update threads $ addToPool (Thread activeThreadId activeThreadPriority activeThreadState (cont activeThreadId))
             return (activeThreadId, Nothing)
      handleSystemCall activeThreadId activeThreadPriority activeThreadState (SpawnThread spawnedThreadProc cont) =
          do spawnedThreadId <- freshThreadId
             C.update threads $ addToPool $ Thread spawnedThreadId Priority.standard activeThreadState spawnedThreadProc
             C.update threads $ addToPool $ Thread activeThreadId activeThreadPriority activeThreadState (cont spawnedThreadId)
             return (activeThreadId, Nothing)
      handleSystemCall activeThreadId activeThreadPriority activeThreadState (KernelFunctionCall interleave kernelFunction cont) =
          do ms <- C.get state
             case run kernelFunction ms of
               Failure e        -> return (activeThreadId, Just e)
               Success (a, ms') -> do C.set state ms'
                                      if interleave
                                      then do C.update threads $ addToPool $ Thread activeThreadId activeThreadPriority activeThreadState (cont a)
                                              return (activeThreadId, Nothing)
                                      else executeSingleStep activeThreadId activeThreadPriority activeThreadState (cont a)
      handleSystemCall activeThreadId activeThreadPriority activeThreadState (Join joinTid cont) =
          do b <- C.with graveyard $ isBuried joinTid
             if b
             then do C.update threads $ addToPool $ Thread activeThreadId activeThreadPriority activeThreadState cont
                     return (activeThreadId, Nothing)
             else C.failure
      handleSystemCall activeThreadId activeThreadPriority activeThreadState (GetThreadPriority cont) =
          do C.update threads $ addToPool $ Thread activeThreadId activeThreadPriority activeThreadState (cont activeThreadPriority)
             return (activeThreadId, Nothing)
      handleSystemCall activeThreadId activeThreadPriority activeThreadState (SetThreadPriority priority cont) =
          do C.update threads $ addToPool $ Thread activeThreadId priority activeThreadState cont
             return (activeThreadId, Nothing)
      handleSystemCall activeThreadId activeThreadPriority activeThreadState (CallCC func cont) =
          executeSingleStep activeThreadId activeThreadPriority activeThreadState (func cont)


final :: MachineState -> Bool
-----------------------------
final = isPoolEmpty . getter threads


data ExecutionTree = Node MachineState (Map.Map ThreadId ExecutionTree)
                   | Leaf (Result Exception MachineState)
                     deriving Show


executionTree :: MachineState -> ExecutionTree
----------------------------------------------
executionTree ms = aux (Success ms)
    where
      aux (Failure e) = Leaf $ Failure e
      aux (Success ms)
          | final ms  = Leaf $ Success ms
          | otherwise = Node ms $ Map.fromList [ (choice, aux ms')
                                               | (choice, ms') <- step ms ]


depthPrune :: Integer -> ExecutionTree -> ExecutionTree
-------------------------------------------------------
depthPrune 0 (Node ms _)        = Leaf $ Success ms
depthPrune n (Node ms children) = Node ms $ Map.map (depthPrune (n - 1)) children
depthPrune _ (Leaf r)           = Leaf r


executionTreeFringe :: ExecutionTree -> [Result Exception MachineState]
-----------------------------------------------------------------------
executionTreeFringe (Node _ children) = do child <- Map.elems children
                                           result <- executionTreeFringe child
                                           return result
executionTreeFringe (Leaf result) = return result


traces :: ExecutionTree -> [Trace]
----------------------------------
traces = aux []
    where
      aux choices (Node _ children) = concat [ aux (choice : choices) child
                                             | (choice, child) <- Map.toList children ]
      aux choices (Leaf result) = [ (choices, result) ]


exception :: String -> [Value] -> Exception
-------------------------------------------
exception str vs = List (Symbol str Nothing : vs) Nothing


initialThreadState :: ThreadState
---------------------------------
initialThreadState = ThreadState Env.empty Env.empty


initialMachineState :: ThreadProcedure Value -> MachineState
------------------------------------------------------------
initialMachineState tp = MachineState Heap.empty trail nextTid threadPool graveyard [0..]
    where
      trail            = Trail []
      tid              = ThreadId.zero
      nextTid          = ThreadId.next tid
      graveyard        = emptyGraveyard
      thread           = Thread tid Priority.standard initialThreadState tp
      threadPool       = createThreadPool [ thread ]


translate :: SE.SExpression SourceLocation -> Value
---------------------------------------------------
translate (SE.Symbol s loc)  = Symbol s (Just loc)
translate (SE.Integer n loc) = Integer n (Just loc)
translate (SE.List xs loc)   = List (map translate xs) (Just loc)
translate (SE.String s loc)  = String s (Just loc)
translate (SE.Keyword s loc) = Keyword s (Just loc)


notCallableException :: Value -> Exception
------------------------------------------
notCallableException v = exception "not-callable" [ v ]


unboundSymbolException :: Value -> Exception
--------------------------------------------
unboundSymbolException s@(Symbol _ _) = exception "unbound-identifier" [ s ]


invalidTypeException :: Value -> TypePredicate -> Exception
-----------------------------------------------------------
invalidTypeException v t = exception "invalid-type" [ v, Symbol (show t) Nothing ]


invalidArgumentCountException :: Exception
------------------------------------------
invalidArgumentCountException = exception "invalid-argument-count" []


invalidException :: String -> [Value] -> Exception
--------------------------------------------------
invalidException str = exception ("invalid-" ++ str)


invalidFixpointException :: [Value] -> Exception
------------------------------------------------
invalidFixpointException = invalidException "fixpoint"


invalidMacroException :: [Value] -> Exception
---------------------------------------------
invalidMacroException = invalidException "macro"


invalidIfException :: [Value] -> Exception
------------------------------------------
invalidIfException = invalidException "if"


invalidDefineException :: [Value] -> Exception
----------------------------------------------
invalidDefineException = invalidException "define"


invalidQuasiquoteException :: [Value] -> Exception
--------------------------------------------------
invalidQuasiquoteException = invalidException "quasiquote"


invalidSpliceException :: [Value] -> Exception
----------------------------------------------
invalidSpliceException = invalidException "splice"


invalidLetException :: [Value] -> Exception
-------------------------------------------
invalidLetException = invalidException "invalid-let"


invalidPatternException :: [Value] -> Exception
-----------------------------------------------
invalidPatternException = invalidException "pattern"


invalidMacroExpandException :: [Value] -> Exception
---------------------------------------------------
invalidMacroExpandException = invalidException "macro-expansion"


invalidMatchException :: [Value] -> Exception
---------------------------------------------
invalidMatchException = invalidException "match"


invalidDictionaryKeyException :: Value -> Exception
---------------------------------------------------
invalidDictionaryKeyException key = invalidException "dictionary-key" [key]


misplacedUnquoteException :: Exception
--------------------------------------
misplacedUnquoteException = exception "misplaced-unquote" []


emptyListException :: Exception
-------------------------------
emptyListException = exception "empty-list" []


invalidAddressException :: Pointer -> Exception
-----------------------------------------------
invalidAddressException ptr = exception "invalid-address" [Address ptr Nothing]


abortException :: [Value] -> Exception
--------------------------------------
abortException = exception "abort"


failedTraceException :: Exception
--------------------------------------------
failedTraceException = exception "failed-trace" []
